home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / INTC.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  37KB  |  1,369 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* continuation of interpreter procedures - part c */
  10.  
  11. /* include standard header files */
  12. #include <stdlib.h>
  13. #include "config.h"
  14. #include "int.h"
  15. #include "ivars.h"
  16. #include "machinep.h"
  17. #include "farithp.h"
  18. #include "intap.h"
  19. #include "intbp.h"
  20. #include "intcp.h"
  21.  
  22. static int get_variable_bound(int *, int []);
  23.  
  24. void rselect(int field)                                                 /*;rselect*/
  25. {
  26.     /*
  27.      *   Perform the Ada record selection operation:
  28.      *
  29.      *     Get the address of the record type template from the TOS
  30.      *     Get the address of the record object from the TOS
  31.      *     Get the number of the component(or field) from the instruction
  32.      *     stream
  33.      *
  34.      *     Check the existence of that particular component in that particular
  35.      *     record(and raise CONSTRAINT_ERROR otherwise)
  36.      *
  37.      *     Push the absolute address of the component on TOS. If component
  38.      *     is an array, push also the address of the array type template.
  39.      *     If the type of this array depends on a discriminant of the  record
  40.      *     a template must be dynamically built.
  41.      */
  42.  
  43.     int
  44.     type_base, type_off, record_base, record_off, field_offset,
  45.         *type_ptr, *record_ptr, *field_table_ptr, *case_table_ptr,
  46.         *case_ptr, type_type, next_case, discr_number, discr_offset,
  47.         first_field, last_field, value_discr, val_high, nb_choices,
  48.         nb_field, nb_fixed, *field_ptr, *component_ptr, *a_type_ptr,
  49.         *u_type_ptr, nb_dim, low, high, comp_off, comp_base, component_size,
  50.         object_size, template_size, *new_type_ptr, *some_ptr;
  51.  
  52.     POP_ADDR(type_base, type_off);
  53.     POP_ADDR(record_base, record_off);
  54.     type_ptr = ADDR(type_base, type_off);
  55.     record_ptr = ADDR(record_base, record_off);
  56.     type_type = TYPE(type_ptr);
  57.  
  58.     /* constrained record subtype */
  59.  
  60.     if (type_type == TT_C_RECORD) {         /* find base type */
  61.         type_base = C_RECORD(type_ptr)->cbase;
  62.         type_off = C_RECORD(type_ptr)->coff;
  63.         type_ptr = ADDR(type_base, type_off);
  64.         type_type = TYPE(type_ptr);
  65.     }
  66.     else if (type_type == TT_D_RECORD) {
  67.         type_base = D_TYPE(type_ptr)->dbase;
  68.         type_off = D_TYPE(type_ptr)->doff;
  69.         type_ptr = ADDR(type_base, type_off);
  70.         type_type = TYPE(type_ptr);
  71.     }
  72.     else if (type_type == TT_RECORD) {
  73.         field_table_ptr = type_ptr + WORDS_RECORD;
  74.         nb_fixed = RECORD(type_ptr)->nb_field;
  75.     }
  76.  
  77.     if (type_type == TT_U_RECORD || type_type == TT_V_RECORD) {
  78.         nb_fixed = U_RECORD(type_ptr)->nb_fixed_u;
  79.         nb_field = U_RECORD(type_ptr)->nb_field_u;
  80.         field_table_ptr = type_ptr + WORDS_U_RECORD;
  81.         case_table_ptr = field_table_ptr + 3 * nb_field;
  82.     }
  83.  
  84.     /* The result is simple to obtain... unless the record has varying size */
  85.  
  86.     if (type_type == TT_V_RECORD) {
  87.         field_offset = 0;
  88.         first_field = 0;
  89.         last_field = nb_fixed - 1;
  90.         next_case = U_RECORD(type_ptr)->first_case;
  91.         nb_discr = U_RECORD(type_ptr)->nb_discr_u;
  92.  
  93.         for (i = 0; i < nb_discr; i++)
  94.             discr_list[i] = *(record_ptr + i);
  95.  
  96.         for (;;) {
  97.             field_ptr = 3 * first_field + field_table_ptr;
  98.             for (i = first_field; i <= MIN((field - 1), last_field); i++) {
  99.                 /* accumulate size of components */
  100.                 component_ptr = ADDR(*(field_ptr + 1), *(field_ptr + 2));
  101.                 field_offset += actual_size(component_ptr, discr_list);
  102.                 field_ptr += 3;
  103.             }
  104.  
  105.             if (field >= first_field && field <= last_field) {
  106.                 break;
  107.             }
  108.             else if (field < first_field  
  109.               ||(field > last_field && next_case == -1)) {
  110.  
  111.                 raise(CONSTRAINT_ERROR, "Record component not present");
  112.                 return;
  113.             }
  114.  
  115.             /*  We have : field > last_field and next_case /= -1 */
  116.  
  117.             case_ptr = case_table_ptr + next_case;
  118.             discr_number = *case_ptr++;
  119.             discr_offset = *(field_table_ptr + 3 * discr_number);
  120.             value_discr = *(record_ptr + discr_offset);
  121.             nb_choices = *case_ptr;
  122.             case_ptr += 4;
  123.             val_high = *case_ptr;
  124.             for (i = 2; i <= nb_choices; i++) {
  125.                 if (val_high > value_discr)
  126.                     break;
  127.                 case_ptr += 4;
  128.                 val_high = *case_ptr;
  129.             }
  130.             next_case = *--case_ptr;
  131.             last_field = *--case_ptr;
  132.             first_field = *--case_ptr;
  133.         }
  134.         field_ptr = field_table_ptr + 3 * field;
  135.     }
  136.  
  137.     /* Record is not varying */
  138.  
  139.     else {
  140.         field_ptr = field_table_ptr + 3 * field;
  141.         field_offset = *field_ptr;
  142.     }
  143.  
  144.     PUSH_ADDR(record_base, field_offset + record_off);
  145.  
  146.     /* check if component is an array */
  147.  
  148.     type_base = *(field_ptr + 1);
  149.     type_off = *(field_ptr + 2);
  150.     type_type = TYPE(ADDR(type_base, type_off));
  151.  
  152.     if ( type_type == TT_S_ARRAY
  153.       || type_type == TT_U_ARRAY
  154.       || type_type == TT_C_ARRAY
  155.       || type_type == TT_D_ARRAY) {
  156.  
  157.         if (type_type == TT_D_ARRAY) {
  158.             /* must build a type template */
  159.             /* necessarily the record is a TT_V_RECORD or a TT_U_RECORD with */
  160.             /* default values for the discriminants */
  161.             nb_discr = U_RECORD(type_ptr)->nb_discr_u;
  162.             for (i = 0; i < nb_discr; i++)
  163.                 discr_list[i] = *(record_ptr + i);
  164.             a_type_ptr = ADDR(type_base, type_off);
  165.             nb_dim = D_TYPE(a_type_ptr)->nb_discr_d;
  166.             type_base = D_TYPE(a_type_ptr)->dbase;
  167.             type_off = D_TYPE(a_type_ptr)->doff;
  168.             u_type_ptr = ADDR(type_base, type_off);
  169.             a_type_ptr += WORDS_D_TYPE;/* =bounds */
  170.             type_type = *u_type_ptr;
  171.  
  172.             if (nb_dim == 1) {
  173.                 /* unidimensional case: we build an s_array */
  174.                 low = get_variable_bound(a_type_ptr, discr_list);
  175.                 a_type_ptr += 2;
  176.                 high = get_variable_bound(a_type_ptr, discr_list);
  177.                 if (type_type == TT_S_ARRAY) {
  178.                     component_size = S_ARRAY(u_type_ptr)->component_size;
  179.                 }
  180.                 else {
  181.                     comp_base = ARRAY(u_type_ptr)->component_base;
  182.                     comp_off = ARRAY(u_type_ptr)->component_offset;
  183.                     component_size = SIZE(ADDR(comp_base, comp_off));
  184.                 }
  185.                 object_size = component_size *(high - low + 1);
  186.                 if (object_size < 0)
  187.                     object_size = 0;
  188.  
  189.                 create(WORDS_S_ARRAY, &type_base, &type_off, &new_type_ptr);
  190.                 S_ARRAY(new_type_ptr)->ttype = TT_S_ARRAY;
  191.                 S_ARRAY(new_type_ptr)->object_size = object_size;
  192.                 S_ARRAY(new_type_ptr)->component_size = component_size;
  193.                 S_ARRAY(new_type_ptr)->index_size = 1;
  194.                 S_ARRAY(new_type_ptr)->salow = low;
  195.                 S_ARRAY(new_type_ptr)->sahigh = high;
  196.             }
  197.  
  198.             else {        /* nb_dim > 1 */
  199.                 template_size = 2 *(nb_dim - 1) + WORDS_ARRAY;
  200.                 create(template_size, &type_base, &type_off, &new_type_ptr);
  201.                 ARRAY(new_type_ptr)->ttype = TT_C_ARRAY;
  202.                 ARRAY(new_type_ptr)->dim = nb_dim;
  203.                 comp_base = ARRAY(u_type_ptr)->component_base;
  204.                 comp_off = ARRAY(u_type_ptr)->component_offset;
  205.                 ARRAY(new_type_ptr)->component_base = comp_base;
  206.                 ARRAY(new_type_ptr)->component_offset = comp_off;
  207.                 component_size = SIZE(ADDR(comp_base, comp_off));
  208.                 /* Beware: indices in reverse order */
  209.                 some_ptr = new_type_ptr + WORDS_ARRAY + 2 * nb_dim - 3;
  210.                 for (i = 1; i <= nb_dim; i++) {
  211.                     low = get_variable_bound(a_type_ptr, discr_list);
  212.                     a_type_ptr += 2;
  213.                     high = get_variable_bound(a_type_ptr, discr_list);
  214.                     a_type_ptr += 2;
  215.                     create(WORDS_I_RANGE, &bas2, &off2, &ptr2);
  216.                     TYPE(ptr2) = TT_I_RANGE;
  217.                     SIZE(ptr2) = 1;
  218.                     I_RANGE(ptr2)->ilow = low;
  219.                     I_RANGE(ptr2)->ihigh = high;
  220.                     *some_ptr-- = off2;
  221.                     *some_ptr-- = bas2;
  222.                     if (high >= low)
  223.                         component_size *= (high - low + 1);
  224.                     else
  225.                         component_size = 0;
  226.                 }
  227.                 SIZE(new_type_ptr) = component_size;
  228.             }
  229.         }
  230.         PUSH_ADDR(type_base, type_off);
  231.     }
  232.  
  233.     /*  no check to perform if done already for varying size records */
  234.  
  235.     if (type_type == TT_V_RECORD)
  236.         return;
  237.  
  238.     first_field = 0;
  239.     last_field = nb_fixed - 1;
  240.     next_case = U_RECORD(type_ptr)->first_case;
  241.  
  242.     for (;;) {
  243.         if ((field >= first_field) &&(field <= last_field)) {
  244.             return;
  245.         }
  246.         else if (field < first_field 
  247.             ||(field > last_field && next_case == -1)) {
  248.             raise(CONSTRAINT_ERROR, "Record component not present");
  249.             return;
  250.         }
  251.  
  252.         /*  then we have : field > last_field and next_case /= -1 */
  253.  
  254.         case_ptr = case_table_ptr + next_case;
  255.         discr_number = *case_ptr++;
  256.         discr_offset = *(field_table_ptr + 3 * discr_number);
  257.         value_discr = *(record_ptr + discr_offset);
  258.         nb_choices = *case_ptr;
  259.         case_ptr += 4;
  260.         val_high = *case_ptr;
  261.         for (i = 2; i <= nb_choices; i++) {
  262.             if (val_high > value_discr) {
  263.                 break